home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / vectors.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-16  |  5.4 KB  |  233 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include "_scm.h"
  45.  
  46.  
  47.  
  48.  
  49. PROC (s_vector_p, "vector?", 1, 0, 0, scm_vector_p);
  50. #ifdef __STDC__
  51. SCM
  52. scm_vector_p(SCM x)
  53. #else
  54. SCM
  55. scm_vector_p(x)
  56.      SCM x;
  57. #endif
  58. {
  59.   if IMP(x) return BOOL_F;
  60.   return VECTORP(x) ? BOOL_T : BOOL_F;
  61. }
  62.  
  63. PROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length);
  64. #ifdef __STDC__
  65. SCM
  66. scm_vector_length(SCM v)
  67. #else
  68. SCM
  69. scm_vector_length(v)
  70.      SCM v;
  71. #endif
  72. {
  73.   ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_vector_length);
  74.   return MAKINUM(LENGTH(v));
  75. }
  76.  
  77. PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
  78. PROC (s_vector, "vector", 0, 0, 1, scm_vector);
  79. #ifdef __STDC__
  80. SCM
  81. scm_vector(SCM l)
  82. #else
  83. SCM
  84. scm_vector(l)
  85.      SCM l;
  86. #endif
  87. {
  88.   SCM res;
  89.   register SCM *data;
  90.   long i = scm_ilength(l);
  91.   ASSERT(i >= 0, l, ARG1, s_vector);
  92.   res = scm_make_vector(MAKINUM(i), UNSPECIFIED);
  93.   data = VELTS(res);
  94.   for(;NIMP(l);l = CDR(l)) *data++ = CAR(l);
  95.   return res;
  96. }
  97.  
  98. PROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref);
  99. #ifdef __STDC__
  100. SCM
  101. scm_vector_ref(SCM v, SCM k)
  102. #else
  103. SCM
  104. scm_vector_ref(v, k)
  105.      SCM v;
  106.      SCM k;
  107. #endif
  108. {
  109.   ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_vector_ref);
  110.   ASSERT(INUMP(k), k, ARG2, s_vector_ref);
  111.   ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_vector_ref);
  112.   return VELTS(v)[((long) INUM(k))];
  113. }
  114.  
  115.  
  116. PROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x);
  117. #ifdef __STDC__
  118. SCM
  119. scm_vector_set_x(SCM v, SCM k, SCM obj)
  120. #else
  121. SCM
  122. scm_vector_set_x(v, k, obj)
  123.      SCM v;
  124.      SCM k;
  125.      SCM obj;
  126. #endif
  127. {
  128.   ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_vector_set_x);
  129.   ASSERT(INUMP(k), k, ARG2, s_vector_set_x);
  130.   ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_vector_set_x);
  131.   VELTS(v)[((long) INUM(k))] = obj;
  132.   return UNSPECIFIED;
  133. }
  134.  
  135.  
  136. PROC (s_make_vector, "make-vector", 1, 1, 0, scm_make_vector);
  137. #ifdef __STDC__
  138. SCM
  139. scm_make_vector(SCM k, SCM fill)
  140. #else
  141. SCM
  142. scm_make_vector(k, fill)
  143.      SCM k;
  144.      SCM fill;
  145. #endif
  146. {
  147.   SCM v;
  148.   register long i;
  149.   register SCM *velts;
  150.   ASSERT(INUMP(k) && (0 <= INUM (k)), k, ARG1, s_make_vector);
  151.   if UNBNDP(fill) fill = UNSPECIFIED;
  152.   i = INUM(k);
  153.   NEWCELL(v);
  154.   DEFER_INTS;
  155.   SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector));
  156.   SETLENGTH(v, i, tc7_vector);
  157.   velts = VELTS(v);
  158.   while(--i >= 0) (velts)[i] = fill;
  159.   ALLOW_INTS;
  160.   return v;
  161. }
  162.  
  163.  
  164. PROC (s_vector_to_list, "vector->list", 1, 0, 0, scm_vector_to_list);
  165. #ifdef __STDC__
  166. SCM
  167. scm_vector_to_list(SCM v)
  168. #else
  169. SCM
  170. scm_vector_to_list(v)
  171.      SCM v;
  172. #endif
  173. {
  174.   SCM res = EOL;
  175.   long i;
  176.   SCM *data;
  177.   ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_vector_to_list);
  178.   data = VELTS(v);
  179.   for(i = LENGTH(v)-1;i >= 0;i--) res = scm_cons(data[i], res);
  180.   return res;
  181. }
  182.  
  183.  
  184. PROC (s_vector_fill_x, "vector-fill!", 2, 0, 0, scm_vector_fill_x);
  185. #ifdef __STDC__
  186. SCM
  187. scm_vector_fill_x(SCM v, SCM fill_x)
  188. #else
  189. SCM
  190. scm_vector_fill_x(v, fill_x)
  191.      SCM v;
  192.      SCM fill_x;
  193. #endif
  194. {
  195.   register long i;
  196.   register SCM *data;
  197.   ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_vector_fill_x);
  198.   data = VELTS(v);
  199.   for(i = LENGTH(v)-1;i >= 0;i--) data[i] = fill_x;
  200.   return UNSPECIFIED;
  201. }
  202.  
  203.  
  204. #ifdef __STDC__
  205. SCM
  206. scm_vector_equal_p(SCM x, SCM y)
  207. #else
  208. SCM
  209. scm_vector_equal_p(x, y)
  210.      SCM x;
  211.      SCM y;
  212. #endif
  213. {
  214.   long i;
  215.   for(i = LENGTH(x)-1;i >= 0;i--)
  216.     if (FALSEP(scm_equal_p(VELTS(x)[i], VELTS(y)[i])))
  217.       return BOOL_F;
  218.   return BOOL_T;
  219. }
  220.  
  221.  
  222. #ifdef __STDC__
  223. void
  224. scm_init_vectors (void)
  225. #else
  226. void
  227. scm_init_vectors ()
  228. #endif
  229. {
  230. #include "vectors.x"
  231. }
  232.  
  233.